home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / glass / glass.lha / GLASS / contsens / size.c < prev    next >
C/C++ Source or Header  |  1991-01-31  |  31KB  |  1,260 lines
  1.  
  2. /*   Copyright (C) 1990 Riet Oolman
  3.  
  4. This file is part of GLASS.
  5.  
  6. GLASS is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. GLASS is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GLASS; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. /* file: size.c
  21.    author: H. Oolman
  22.    last modified: 13-7-1990
  23.    purpose: procedures for checking if connections have the
  24.             required size, and replacing ':' and indexing by
  25.             something equivalent.
  26.             Assuming that the input was type-correct Glass, and
  27.             passed through the macro-expander
  28.    modifications: p2c translated, tmc access procs
  29. */
  30.  
  31. #include "handleds.h"
  32. #include "check.ds.h"
  33. #include "check.var.h"
  34. #include "check.afuncs.h"
  35. #include "errorenv.h"
  36. #include "unification.h"
  37. #include "size.h"
  38.  
  39. Local typcrec *typeval PP((int appnon, val vl, envrec *btns,
  40.                   long splitlevel));
  41.  
  42. Local Void unparsfc(f, fc)
  43. FILE *f;
  44. formcon fc;
  45. {
  46.   /* unparses formconptr's */
  47.   switch (fc->tag) {
  48.  
  49.   case TAGFCComp:
  50.     putc('(', f);
  51.     unparsfc(f, fc->FCComp.fcfirst);
  52.     fprintf(f, "): ");
  53.     unparsfc(f, fc->FCComp.fcrest);
  54.     break;
  55.  
  56.   case TAGFCList:
  57.     putc('[', f);
  58.     fc = fc->FCList.l;
  59.     while (fc != NULL) {
  60.       unparsfc(f, fc);
  61.       fc = fc->next;
  62.       if (fc != NULL)
  63.      fprintf(f, ", ");
  64.     }
  65.     putc(']', f);
  66.     break;
  67.  
  68.   case TAGFCSym:
  69.     Writesymbol(f, fc->FCSym.sym);
  70.     break;
  71.   }
  72. }  /* unparsfc */
  73.  
  74. Local Void unparsval(f, vl)
  75. FILE *f;
  76. val vl;
  77. {
  78.   /* unparses (most) val's */
  79.   parval atv;
  80.  
  81.   switch (vl->tag) {
  82.  
  83.   case TAGVSym:
  84.     Writesymbol(f, vl->VSym.sym);
  85.     break;
  86.  
  87.   case TAGVAtom:
  88.     Writesymbol(f, vl->VAtom.atnm);
  89.     atv = vl->VAtom.atvpar;
  90.     while (atv != NULL) {
  91.       putc(' ', f);
  92.       switch (atv->tag) {
  93.  
  94.       case TAGParInt:
  95.      fprint_inum(f, atv->ParInt.i);
  96.      break;
  97.  
  98.       case TAGParFlo:
  99.      fprint_fnum(f, atv->ParFlo.f);
  100.      break;
  101.  
  102.       case TAGParStr:
  103.      fprint_string(f, atv->ParStr.s);
  104.      break;
  105.  
  106.       case TAGParBool:
  107.      if (atv->ParBool.b)
  108.        fprintf(f, "TRUE");
  109.      else
  110.        fprintf(f, "FALSE");
  111.      break;
  112.       }
  113.       atv = atv->next;
  114.     }
  115.     fprintf(f, " (");
  116.     unparsval(f, vl->VAtom.atcpar);
  117.     putc(')', f);
  118.     break;
  119.  
  120.   case TAGVLambda:
  121.     if (vl->VLambda.lval == NULL)
  122.       unparsfc(f, vl->VLambda.lpar);
  123.     else {
  124.       putc('%', f);
  125.       unparsfc(f, vl->VLambda.lpar);
  126.       putc('.', f);
  127.       unparsval(f, vl->VLambda.lval);
  128.     }
  129.     break;
  130.  
  131.   case TAGVSigma:
  132.     putc('$', f);
  133.     unparsfc(f, vl->VSigma.spar);
  134.     putc('.', f);
  135.     unparsval(f, vl->VSigma.sval);
  136.     break;
  137.  
  138.   case TAGVApply:
  139.     unparsval(f, vl->VApply.aval);
  140.     fprintf(f, " (");
  141.     unparsval(f, vl->VApply.apar);
  142.     putc(')', f);
  143.     break;
  144.  
  145.   case TAGVWhere:
  146.     unparsval(f, vl->VWhere.wval);
  147.     if (vl->VWhere.wdefs != NULL)
  148.       fprintf(f, " Where .... Endwhere");
  149.     break;
  150.  
  151.   case TAGVList:
  152.     putc('[', f);
  153.     vl = vl->VList.l;
  154.     while (vl != NULL) {
  155.       unparsval(f, vl);
  156.       vl = vl->next;
  157.       if (vl != NULL)
  158.      fprintf(f, ", ");
  159.     }
  160.     putc(']', f);
  161.     break;
  162.  
  163.   case TAGVAppset:
  164.     putc('{', f);
  165.     vl = vl->VAppset.aps;
  166.     while (vl != NULL) {
  167.       unparsval(f, vl);
  168.       vl = vl->next;
  169.       if (vl != NULL)
  170.      fprintf(f, ", ");
  171.     }
  172.     putc('}', f);
  173.     break;
  174.  
  175.   case TAGVSyn:
  176.     fprintf(f, "*[");
  177.     vl = vl->VSyn.synlist;
  178.     while (vl != NULL) {
  179.       unparsval(f, vl);
  180.       vl = vl->next;
  181.       if (vl != NULL)
  182.      fprintf(f, ", ");
  183.     }
  184.     putc(']', f);
  185.     break;
  186.  
  187.   case TAGVInd:
  188.     unparsval(f, vl->VInd.vexp);
  189.     putc(' ', f);
  190.     fprint_inum(f, vl->VInd.vind);
  191.     break;
  192.  
  193.   case TAGVSlice:
  194.     unparsval(f, vl->VSlice.vexps);
  195.     fprintf(f, " @(");
  196.     fprint_inum(f, vl->VSlice.vind1);
  197.     fprintf(f, ")...(");
  198.     fprint_inum(f, vl->VSlice.vind2);
  199.     putc(')', f);
  200.     break;
  201.  
  202.   case TAGVComp:
  203.     putc('(', f);
  204.     unparsval(f, vl->VComp.vfirst);
  205.     fprintf(f, "): ");
  206.     unparsval(f, vl->VComp.vrest);
  207.     break;
  208.   }
  209. }  /* unparsval */
  210.  
  211. Local dirgraphrec *extractdirs(t)
  212. typ t;
  213. { /* extract the directions in a systemtype. Easy for comparing */
  214.  
  215.   switch (t->tag) {
  216.  
  217.   case TAGTypUni:
  218.     return BuildCd(BuildOd(BuildIN()),
  219.                BuildCd(BuildOd(BuildOUT()),
  220.                        BuildOd(BuildNON())));
  221.     break;
  222.  
  223.   case TAGTypNon:
  224.     return extractdirs(t->TypNon.nontyp);
  225.     break;
  226.  
  227.   case TAGTypProd:
  228.     if (t->TypProd.ptypes == NULL)
  229.       return BuildOd(BuildNON());
  230.     else {
  231.       return BuildCd(extractdirs(t->TypProd.ptypes),
  232.             extractdirs(new_TypProd(t->TypProd.ptypes->next)));
  233.     }
  234.     break;
  235.  
  236.   case TAGTypBase:
  237.     return BuildOd(BuildNON());
  238.     break;
  239.  
  240.   case TAGTypIn:
  241.     return BuildOd(BuildIN());
  242.     break;
  243.  
  244.   case TAGTypOut:
  245.     return BuildOd(BuildOUT());
  246.     break;
  247.  
  248.   case TAGTypSym:
  249.     return BuildOd(BuildNON());
  250.     break;
  251.   }
  252. }
  253.  
  254. Local typcrec *convtype(partyps, glty, btns, mustsy)
  255. partyp partyps;
  256. typ glty;
  257. envrec *btns;
  258. boolean mustsy;
  259. { /* partyps: parametertypes before glty
  260.      glty: glass type to be converted to tc form
  261.      btns: TN names plus types in glty
  262.      mustsy: glty must be a system type */
  263.   symbol n;
  264.   typcrec *t1, *t2, *tc;
  265.   if (mustsy && glty->tag != TAGTypUni && glty->tag != TAGTypNon
  266.       && glty->tag != TAGTypSym)
  267.     error(23L, NULL, NULL, NULL, NULL, false);
  268.   if (partyps != NULL) {
  269.     t2 = convtype(partyps->next, glty, btns, false);
  270.     switch (partyps->tag) {
  271.  
  272.     case TAGPTInt:
  273.       t1 = BuildINT();
  274.       break;
  275.  
  276.     case TAGPTFlo:
  277.       t1 = BuildFLOAT();
  278.       break;
  279.  
  280.     case TAGPTStr:
  281.       t1 = BuildSTRING();
  282.       break;
  283.  
  284.     case TAGPTBool:
  285.       t1 = BuildBOOL();
  286.       break;
  287.     }
  288.     return (BuildSINGLEARROW(t1, t2));
  289.   }
  290.   switch (glty->tag) {
  291.  
  292.   case TAGTypBase:
  293.     n = glty->TypBase.basenm;
  294.     tc = lookup(btns, &n);
  295.     if (tc == NULL) {
  296.       error(1L, NULL, NULL, n, NULL, false);
  297.       /* should not occur */
  298.       return BuildUNKNOWN(newname(), false, false);
  299.     } else
  300.       return tc;
  301.     break;
  302.  
  303.   case TAGTypIn:
  304.     return convtype(NULL, glty->TypIn.ityp, btns, false);
  305.     break;
  306.  
  307.   case TAGTypOut:
  308.     return convtype(NULL, glty->TypOut.otyp, btns, false);
  309.     break;
  310.  
  311.   case TAGTypUni:
  312.     return BuildSYSTY(extractdirs(glty),
  313.      BuildCT(convtype(NULL, glty->TypUni.uityp, btns, false),
  314.           BuildCT(convtype(NULL, glty->TypUni.uotyp, btns,false),
  315.                BuildEMPTYT())));
  316.     break;
  317.  
  318.   case TAGTypNon:
  319.     return BuildSYSTY(extractdirs(glty),
  320.                convtype(NULL, glty->TypNon.nontyp, btns, false));
  321.     break;
  322.  
  323.   case TAGTypProd:
  324.     if (glty->TypProd.ptypes == NULL)
  325.       return BuildEMPTYT();
  326.     else { 
  327.     return
  328.     BuildCT(convtype(NULL,glty->TypProd.ptypes,btns,false),
  329.        convtype(NULL,new_TypProd(glty->TypProd.ptypes->next),
  330.                 btns, false));
  331.     }
  332.     break;
  333.  
  334.   case TAGTypSym:
  335.     n = glty->TypSym.sym;
  336.     tc = lookup(btns, &n);
  337.     if (tc == NULL) {
  338.       error(1L, NULL, NULL, n, NULL, false);
  339.       /* should not occur */
  340.       return BuildUNKNOWN(newname(), false, false);
  341.     } else
  342.       return tc;
  343.     break;
  344.   }
  345. }  /* convtype */
  346.  
  347. Local envrec *extendbtns(elts, btns)
  348. def elts;
  349. envrec *btns;
  350. {
  351.   /* btns: environment of TYPE names + tc-form of defining types;
  352.      elts: list of defs, the TYPEs from which are to extend btns
  353.            for forming the result;
  354.      in the tc types in this btns env. names for TY have been
  355.      replaced by redirections to the defining types */
  356.   def hel;
  357.   symbol n;
  358.   typcrec *ut, *t;
  359.   orig oo;
  360.  
  361.   hel = elts;
  362.   while (hel != NULL) {
  363.     if (hel->tag == TAGDefBasetype)
  364.       update(&btns, hel->DefBasetype.basename,
  365.           BuildBASETY(hel->DefBasetype.basename, newname(),
  366.                       hel->DefBasetype.baseorig));
  367.     else {
  368.       if (hel->tag == TAGDefTyp)
  369.      update(&btns, hel->DefTyp.typnm, 
  370.             BuildUNKNOWN(newname(), false, false));
  371.     }
  372.     /* fist put all typenamings in btns with unknown type */
  373.     hel = hel->next;
  374.   }
  375.   hel = elts;
  376.   while (hel != NULL) {
  377.     if (hel->tag == TAGDefTyp) {
  378.       n = hel->DefTyp.typnm;
  379.       addcopy(n, &nestednames);
  380.       oo = nestednorig;
  381.       nestednorig = hel->DefTyp.typorig;
  382.       t = convtype(NULL, hel->DefTyp.typas, btns, true);
  383.       nestednames = nestednames->next;
  384.       nestednorig = oo;
  385.       ut = lookup(btns, &n);
  386.       /* replace the unknown type by indir. to the found one */
  387.       becomes(ut, t);
  388.     }
  389.     hel = hel->next;
  390.   }
  391.   return btns;
  392. }  /* extendbtns */
  393.  
  394. Local Void extendenvloc(elts, btns)
  395. def elts;
  396. envrec *btns;
  397. {
  398.   /* put types of ATOMs, DEFs in curenv, given btns for names in
  399.      the declared types */
  400.   def hel;
  401.   orig oo;
  402.  
  403.   hel = elts;
  404.   while (hel != NULL) {
  405.     if (hel->tag == TAGDefVal) {
  406.       addcopy(hel->DefVal.valnm, &nestednames);
  407.       oo = nestednorig;
  408.       nestednorig = hel->DefVal.valorig;
  409.       update(&curenv, hel->DefVal.valnm,
  410.           convtype(NULL, hel->DefVal.valtyp, btns, true));
  411.       nestednames = nestednames->next;
  412.       nestednorig = oo;
  413.     } else {
  414.       if (hel->tag == TAGDefAtom) {
  415.      addcopy(hel->DefAtom.atnm, &nestednames);
  416.      oo = nestednorig;
  417.      nestednorig = hel->DefAtom.atorig;
  418.      update(&curenv, hel->DefAtom.atnm,
  419.             convtype(hel->DefAtom.atptyp, hel->DefAtom.atctyp,
  420.                      btns, true));
  421.      nestednames = nestednames->next;
  422.      nestednorig = oo;
  423.       }
  424.     }
  425.     hel = hel->next;
  426.   }
  427. }  /* extendenvloc */
  428.  
  429. Local typcrec *typefc(fc)
  430. formcon fc;
  431. {
  432.   /* gives type of fc; adds types for names to curenv
  433.      type for name not overwritten */
  434.   typcrec *t1;
  435.   symbol hn;
  436.  
  437.   switch (fc->tag) {
  438.  
  439.   case TAGFCComp:
  440.     t1 = typefc(fc->FCComp.fcrest);
  441.     fc->FCComp.typfc = t1;
  442.     return BuildCT(typefc(fc->FCComp.fcfirst), t1);
  443.     break;
  444.  
  445.   case TAGFCList:
  446.     if (fc->FCList.l == NULL)
  447.       return BuildEMPTYT();
  448.     else {
  449.       return BuildCT(typefc(fc->FCList.l),
  450.                        typefc(new_FCList(fc->FCList.l->next)));
  451.     }
  452.     break;
  453.  
  454.   case TAGFCSym:
  455.     hn = fc->FCSym.sym;
  456.     t1 = lookup(curenv, &hn);
  457.     if (t1 == NULL) {
  458.       t1 = BuildUNKNOWN(newname(), false, true);
  459.       update(&curenv, hn, t1);
  460.     }
  461.     return t1;
  462.     break;
  463.   }
  464. }  /* typefc */
  465.  
  466. #define forcefctoval(f) new_VLambda(f, NULL)
  467. /* forcefctoval(f) new_VLambda(f, NULL):
  468.     forces an formcon to look like a val by putting a
  469.     TAGVLambda with empty lval field around it */
  470.  
  471. #define NoOrig  new_orig("nofile", 0L)
  472. /* NoOrig  new_orig("nofile", 0L): a value for orig if there is none */
  473.  
  474. Local boolean tuptyp(ty, size)
  475. typcrec *ty;
  476. long *size;
  477. {
  478.   /* checks if ty does not end in something else than empty, and
  479.      if not, delivers the number of component types */
  480.  
  481.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  482.   if (ty->kind == kindCT) {
  483.     if (!tuptyp(ty->CT.tcrest, size))
  484.       return false;
  485.     (*size)++;
  486.     return true;
  487.   } else if (ty->kind == kindEMPTYT) {
  488.     *size = 0;
  489.     return true;
  490.   } else return false;
  491. }  /* tuptyp */
  492.  
  493. Local val VSymlist(size)
  494. long size;
  495. {
  496.   /* delivers '[unu_'_extsupply, ... , unu_'_extsupply+size-1
  497.      extsupply is increased by size */
  498.   symbol unu;
  499.   val hv, hvl, list;
  500.   long i;
  501.  
  502.   hvl = NULL;
  503.   list = NULL;
  504.   for (i = 0; i < size; i++) {
  505.     unu = Buildsymbol("unu_'", 5L);
  506.     addext(unu, extsupply);
  507.     extsupply++;
  508.     hv = new_VSym(NoOrig, unu);
  509.     if (hvl == NULL)
  510.       list = hv;
  511.     else
  512.       hvl->next = hv;
  513.     hvl = hv;
  514.   }
  515.   return new_VList(list);
  516. }  /* VSymlist */
  517.  
  518. Local Void FCSymVSymlist(size, flist, vlist)
  519. long size;
  520. formcon *flist;
  521. val *vlist;
  522. {
  523.   /* delivers '[unu_'_extsupply, ... , unu_'_extsupply+size-1 as
  524.      valptr and formconptr; extsupply is increased by size */
  525.   symbol unu;
  526.   formcon hf, hfl;
  527.   val hv, hvl;
  528.   long i;
  529.  
  530.   hvl = NULL;
  531.   *flist = NULL;
  532.   *vlist = NULL;
  533.   for (i = 0; i < size; i++) {
  534.     unu = Buildsymbol( "unu_'", 5L);
  535.     addext(unu, extsupply);
  536.     extsupply++;
  537.     hf = new_FCSym(unu);
  538.     hv = new_VSym(NoOrig, unu);
  539.     if (hvl == NULL) {
  540.       *flist = hf;
  541.       *vlist = hv;
  542.     } else {
  543.       hfl->next = hf;
  544.       hvl->next = hv;
  545.     }
  546.     hfl = hf;
  547.     hvl = hv;
  548.   }
  549.   *flist = new_FCList(*flist);
  550.   *vlist = new_VList(*vlist);
  551. }  /* FCSymVSymlist */
  552.  
  553. Local Void rcifc(fc, newwheres)
  554. formcon fc;
  555. def *newwheres;
  556. { /* does the same as replconsind(fc,true,newwheres) */
  557.   def nw1, nw2;
  558.   formcon ff, fr;
  559.   val vr;
  560.   long k;
  561.  
  562.   switch (fc->tag) {
  563.  
  564.   case TAGFCComp:
  565.     if (tuptyp(fc->FCComp.typfc, &k)) {
  566.       rcifc(fc->FCComp.fcfirst, &nw1);
  567.       rcifc(fc->FCComp.fcrest, &nw2);
  568.       *newwheres=app_def_list(nw1, nw2);
  569.       if (fc->FCComp.fcrest->tag == TAGFCList)
  570.      fr = fc->FCComp.fcrest;
  571.       else {
  572.      if (fc->FCComp.fcrest->tag == TAGFCSym) {
  573.        FCSymVSymlist(k, &fr, &vr);
  574.        *newwheres=
  575.        app_def_list
  576.          (new_DefCon
  577.             (NoOrig, 
  578.              new_VSym(NoOrig, fc->FCComp.fcrest->FCSym.sym),
  579.              vr), 
  580.          *newwheres);
  581.      }
  582.       }
  583.       ff = fc->FCComp.fcfirst;
  584.       fc->tag = TAGFCList;
  585.       fc->FCList.l = ff;
  586.       fc->FCList.l->next = fr->FCList.l;
  587.     } else {
  588.       error(27L, NULL, NULL, NULL, forcefctoval(fc), false);
  589.       *newwheres = NULL;
  590.     }
  591.     break;
  592.  
  593.   case TAGFCSym:
  594.     *newwheres = NULL;
  595.     break;
  596.  
  597.   case TAGFCList:
  598.     nw2 = NULL;
  599.     ff = fc->FCList.l;
  600.     while (ff != NULL) {
  601.       rcifc(ff, &nw1);
  602.       nw2=app_def_list(nw2, nw1);
  603.       ff = ff->next;
  604.     }
  605.     *newwheres = nw2;
  606.     break;
  607.   }
  608. }  /* rcifc */
  609.  
  610. Local Void replconsind(vl, isw, newwheres)
  611. val vl;
  612. boolean isw;
  613. def *newwheres;
  614. {
  615.   /* replace 
  616.      'x:y' by [x,y0,...,yn-1]
  617.      'y i' (indexing) by yi   WHERE [y0,...,yn-1] = y ENDWHERE
  618.      'y@i...j' by [yi,...,yj]
  619.      if y has n components (n deduced from y's type)
  620.      An error occurs if the exact size of y is not known
  621.      isw: vl is used as the lhs in a where equation */
  622.   def nw1, nw2, d;
  623.   val vf, vr, hvl, hvn;
  624.   long i, k, ind1, ind2;
  625.  
  626.   switch (vl->tag) {
  627.   case TAGVComp:
  628.     if (tuptyp(vl->VComp.typvc, &k)) {
  629.       replconsind(vl->VComp.vfirst, isw, &nw1);
  630.       replconsind(vl->VComp.vrest, isw, &nw2);
  631.       *newwheres=app_def_list(nw1, nw2);
  632.       if (vl->VComp.vrest->tag == TAGVList)
  633.      vr = vl->VComp.vrest;
  634.       else {
  635.      vr = VSymlist(k);
  636.      if (isw)
  637.        d=new_DefCon(NoOrig, vl->VComp.vrest, vr);
  638.      else
  639.        d=new_DefCon(NoOrig, vr, vl->VComp.vrest);
  640.      *newwheres=app_def_list(d, *newwheres);
  641.       }
  642.       vf = vl->VComp.vfirst;
  643.       vl->tag = TAGVList;
  644.       vl->VList.l = vf;
  645.       vl->VList.l->next = vr->VList.l;
  646.     } else {
  647.       error(27L, NULL, NULL, NULL, vl, false);
  648.       *newwheres = NULL;
  649.     }
  650.     break;
  651.  
  652.   case TAGVInd:
  653.     if (tuptyp(vl->VInd.typvi, &k)) {
  654.       replconsind(vl->VInd.vexp, false, newwheres);
  655.       if (vl->VInd.vexp->tag == TAGVList)
  656.      vr = vl->VInd.vexp;
  657.       else {
  658.      vr = VSymlist(k);
  659.      if (isw)
  660.        d=new_DefCon(NoOrig, vl->VInd.vexp, vr);
  661.      else
  662.        d=new_DefCon(NoOrig, vr, vl->VInd.vexp);
  663.      *newwheres=app_def_list(d, *newwheres);
  664.       }
  665.       vr = vr->VList.l;
  666.       ind1 = vl->VInd.vind;
  667.       for (i = 0; i < ind1; i++)
  668.      vr = vr->next;
  669.       vf = vl->next;
  670.       *vl = *vr;
  671.       vl->next = vf;
  672.     } else {
  673.       error(27L, NULL, NULL, NULL, vl, false);
  674.       *newwheres = NULL;
  675.     }
  676.     break;
  677.  
  678.   case TAGVSlice:
  679.     ind1 = vl->VSlice.vind1;
  680.     ind2 = vl->VSlice.vind2;
  681.     if (ind2 < ind1) {
  682.       vl->tag = TAGVList;
  683.       vl->VList.l = NULL;
  684.       *newwheres = NULL;
  685.     } else {
  686.       if (tuptyp(vl->VSlice.typvs, &k)) {
  687.      replconsind(vl->VSlice.vexps, false, newwheres);
  688.      if (vl->VSlice.vexps->tag == TAGVList)
  689.        vr = vl->VSlice.vexps;
  690.      else {
  691.        vr = VSymlist(k);
  692.        if (isw)
  693.          d=new_DefCon(NoOrig, vl->VSlice.vexps, vr);
  694.        else
  695.          d=new_DefCon(NoOrig, vr, vl->VSlice.vexps);
  696.        *newwheres=app_def_list(d, *newwheres);
  697.      }
  698.      vr = vr->VList.l;
  699.      for (i = 0; i < ind1; i++)
  700.        vr = vr->next;
  701.      k = ind2 - ind1;
  702.      hvl = (val )malloc(sizeof(*hvl));
  703.      *hvl = *vr;
  704.      vf = hvl;
  705.      for (i = 0; i < k; i++) {
  706.        vr = vr->next;
  707.        hvn = (val )malloc(sizeof(*hvn));
  708.        *hvn = *vr;
  709.        hvl->next = hvn;
  710.        hvl = hvn;
  711.      }
  712.      hvl->next = NULL;
  713.      vl->tag = TAGVList;
  714.      vl->VList.l = vf;
  715.       } else {
  716.      error(27L, NULL, NULL, NULL, vl, false);
  717.      *newwheres = NULL;
  718.       }
  719.     }
  720.     break;
  721.  
  722.   case TAGVSym:
  723.     *newwheres = NULL;
  724.     break;
  725.  
  726.   case TAGVLambda:
  727.     rcifc(vl->VLambda.lpar, &nw1);
  728.     replconsind(vl->VLambda.lval, false, &nw2);
  729.     nw2 = app_def_list(nw1,nw2);
  730.     if (nw2!=NULL)
  731.     { if (vl->VLambda.lval->tag == TAGVWhere) {      
  732.         vl->VLambda.lval->VWhere.wdefs =
  733.          app_def_list(nw2, vl->VLambda.lval->VWhere.wdefs);
  734.       } else {
  735.         vl->VLambda.lval = new_VWhere(nw2, vl->VLambda.lval);
  736.       };
  737.     }
  738.     *newwheres = NULL;
  739.     break;
  740.  
  741.   case TAGVSigma:
  742.     rcifc(vl->VSigma.spar, &nw1);
  743.     replconsind(vl->VSigma.sval, false, &nw2);
  744.     nw2=app_def_list(nw1,nw2);
  745.     if (nw2!=NULL)
  746.     { if (vl->VSigma.sval->tag == TAGVWhere) {      
  747.         vl->VSigma.sval->VWhere.wdefs =
  748.           app_def_list(nw2, vl->VSigma.sval->VWhere.wdefs);
  749.       } else {
  750.         vl->VSigma.sval = new_VWhere(nw2,vl->VSigma.sval);
  751.       };
  752.     }
  753.     *newwheres = NULL;
  754.     break;
  755.  
  756.   case TAGVApply:
  757.     replconsind(vl->VApply.aval, false, &nw1);
  758.     replconsind(vl->VApply.apar, false, &nw2);
  759.     *newwheres=app_def_list(nw1, nw2);
  760.     break;
  761.  
  762.   case TAGVWhere:
  763.     replconsind(vl->VWhere.wval, false, &nw2);
  764.     d = vl->VWhere.wdefs;
  765.     while (d != NULL) {
  766.       if (d->tag == TAGDefCon) {
  767.      replconsind(d->DefCon.defcon, true, &nw1);
  768.      nw2=app_def_list(nw2, nw1);
  769.      replconsind(d->DefCon.conas, false, &nw1);
  770.      nw2=app_def_list(nw2, nw1);
  771.       } else {
  772.      if (d->tag == TAGDefVal)
  773.        replconsind(d->DefVal.valas, false, &nw2);
  774.       }
  775.       d = d->next;
  776.     }
  777.     if (vl->VWhere.wdefs != NULL) {
  778.       vl->VWhere.wdefs = app_def_list(nw2, vl->VWhere.wdefs);
  779.       *newwheres = NULL;
  780.     } else
  781.       *newwheres = nw2;
  782.     break;
  783.  
  784.   case TAGVList:
  785.     nw2 = NULL;
  786.     hvl = vl->VList.l;
  787.     while (hvl != NULL) {
  788.       replconsind(hvl, isw, &nw1);
  789.       nw2=app_def_list(nw2, nw1);
  790.       hvl = hvl->next;
  791.     }
  792.     *newwheres = nw2;
  793.     break;
  794.  
  795.   case TAGVAppset:
  796.     nw2 = NULL;
  797.     hvl = vl->VAppset.aps;
  798.     while (hvl != NULL) {
  799.       replconsind(hvl, false, &nw1);
  800.       nw2=app_def_list(nw2, nw1);
  801.       hvl = hvl->next;
  802.     }
  803.     *newwheres = nw2;
  804.     break;
  805.  
  806.   case TAGVSyn:
  807.     nw2 = NULL;
  808.     hvl = vl->VSyn.synlist;
  809.     while (hvl != NULL) {
  810.       replconsind(hvl, false, &nw1);
  811.       nw2=app_def_list(nw2, nw1);
  812.       hvl = hvl->next;
  813.     }
  814.     *newwheres = nw2;
  815.     break;
  816.  
  817.   case TAGVAtom:
  818.     replconsind(vl->VAtom.atcpar, false, newwheres);
  819.     break;
  820.   }
  821. }  /* replconsind */
  822.  
  823. Local Void checkdm(dm, ty, btns)
  824. val dm;
  825. typcrec *ty;
  826. envrec *btns;
  827. {
  828.   /* check if def dm has required size in type ty
  829.      ty: type of dm
  830.      btns: TNs holding on this level */
  831.   mark_(&curenv);
  832.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  833.   compat(typeval(false, dm, btns, 0L), ty, dm);
  834.   release_(&curenv, false);   /* remove conn. names */
  835. }  /* checkdm */
  836.  
  837. Local Void checkdms(elts, btns)
  838. def elts;
  839. envrec *btns;
  840. {
  841.   /* check each DEF in the elts-list for size corr., given
  842.      btns for names in the declared types */
  843.   def hel;
  844.   symbol n;
  845.   orig oo;
  846.  
  847.   hel = elts;
  848.   while (hel != NULL) {
  849.     if (hel->tag == TAGDefVal) {
  850.       n = hel->DefVal.valnm;
  851.       addcopy(n, &nestednames);
  852.       oo = nestednorig;
  853.       nestednorig = hel->DefVal.valorig;
  854.       checkdm(hel->DefVal.valas, lookup(curenv, &n), btns);
  855.       nestednames = nestednames->next;
  856.       nestednorig = oo;
  857.     }
  858.     hel = hel->next;
  859.   }
  860. }  /* checkdms */
  861.  
  862. Local typcrec *typename(n)
  863. symbol *n;
  864. {
  865.   /* find type of n in curenv; if not there, give it any conn.
  866. type */
  867.   typcrec *t;
  868.  
  869.   t = lookup(curenv, n);
  870.   if (t == NULL) {
  871.     t = BuildUNKNOWN(newname(), false, true);
  872.     update(&curenv, *n, t);
  873.   }
  874.   return t;   /* no loc. ty. vars, t* or t^e */
  875. }  /* typename */
  876.  
  877. Local typcrec *typeld(ld, btns, splitlevel)
  878. def ld;
  879. envrec *btns;
  880. long splitlevel;
  881. {
  882.   /* if ld (appearing in where) is of the form "ns=e" or appset
  883.      then check its type; result type is APS
  884.      splitlevel: same function as in typeval */
  885.   typcrec *t1;
  886.  
  887.   if (ld->tag!=TAGDefCon) /*appsets in where not (yet) in d.s. */
  888.     return (BuildAPS());
  889.   t1 = BuildUNKNOWN(newname(), false, true);
  890.   compat(t1, typeval(false, ld->DefCon.defcon, btns, splitlevel),
  891.       ld->DefCon.defcon);
  892.   compat(t1, typeval(false, ld->DefCon.conas, btns, splitlevel),
  893.       ld->DefCon.conas);
  894.   return (BuildAPS());
  895. }  /* typeld */
  896.  
  897. Local Void splitcurenv(splitlevel, ce, le)
  898. long splitlevel;
  899. envrec **ce, **le;
  900. {
  901.   /* curenv contains: 
  902.      conn. names;mark;ADMnames_n;mark;conn. names_n;mark;... ;
  903.      ADMnames_0;mark;connnames_0;mark;explicitly declared names
  904.      ce will contain: 
  905.      conn. names;conn. names_n;mark;...; ADMnames_0; mark;
  906.      connnames_0; mark;explicitly declared names
  907.      le will contain: 
  908.      ADMnames_n;mark; ... ; ADMnames_0;explicitly declared names
  909.      n = splitlevel
  910.   */
  911.   envrec *h, *h2, *hold;
  912.   long i;
  913.  
  914.   hold = NULL;
  915.   h = curenv;
  916.   while (!ismark(h)) {
  917.     hold = h;
  918.     h = h->next;
  919.   }
  920.   h = h->next;
  921.   *le = h;
  922.   while (!ismark(h))
  923.     h = h->next;
  924.   if (hold == NULL)
  925.     *ce = h->next;
  926.   else {
  927.     *ce = curenv;
  928.     hold->next = h->next;
  929.   }
  930.   hold = h;
  931.   h = h->next;
  932.   for (i = 1; i <= splitlevel; i++) {
  933.     while (!ismark(h))
  934.       h = h->next;
  935.     h = h->next;
  936.     while (!ismark(h)) {
  937.       h2 = (envrec *)malloc(sizeof(envrec));
  938.       *h2 = *h;
  939.       hold->next = h2;
  940.       hold = h2;
  941.       h = h->next;
  942.     }
  943.   }
  944.   while (!ismark(h))
  945.     h = h->next;
  946.   hold->next = h->next;
  947. }  /* splitcurenv */
  948.  
  949. Local Void atleast(vi, ty, vl)
  950. long vi;
  951. typcrec *ty;
  952. val vl;
  953. { /* see that ty has at least vi subparts; 
  954.      vl: where this is checked */
  955.   typcrec *t, *t1;
  956.  
  957.   if (vi <= 0)
  958.     return;
  959.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  960.   switch (ty->kind) {
  961.  
  962.   case kindCT:
  963.     atleast(vi - 1, ty->CT.tcrest, vl);
  964.     break;
  965.  
  966.   case kindSOME:
  967.     t1 = ty->SOME.tcpart;
  968.     t = BuildSOME(t1, newname());
  969.     while (vi > 0) {
  970.       t = BuildCT(t1, t);
  971.       vi--;
  972.     }
  973.     becomes(ty, t);
  974.     break;
  975.  
  976.   case kindEMPTYT:
  977.     error(24L, NULL, NULL, NULL, vl, false);
  978.     break;
  979.  
  980.   case kindUNKNOWN:
  981.     becomes(ty,BuildSOME(BuildUNKNOWN(newname(), false,
  982.                                       ty->UNKNOWN.mustconn),
  983.                  newname()));
  984.     /* !! hier ook gevaar verkeerde invulling? */
  985.     atleast(vi, ty, vl);
  986.     break;
  987.  
  988.   case kindSINGLEARROW:
  989.   case kindINT:
  990.   case kindFLOAT:
  991.   case kindBOOL:
  992.   case kindSTRING:
  993.   case kindSYSTY:
  994.   case kindLOC:
  995.   case kindBASETY:
  996.   case kindALL:
  997.   case kindAPS:
  998.     /* blank case */
  999.     break;
  1000.   }
  1001. }  /* atleast */
  1002. Local typcrec *selecttypes(ind1, ind2, ty)
  1003. long ind1, ind2;
  1004. typcrec *ty;
  1005. {
  1006.   /* ty is a type ty_0 CT (.... CT (ty_n-1 CT rest)) (with
  1007.      possibly INDIRs) if no error occurred.
  1008.      The result is to be ty_ind1 CT ( ... (ty_ind2 CT EMPTYT)) */
  1009.   
  1010.   if (ind2 < ind1) return (BuildEMPTYT());
  1011.   while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
  1012.   if (ty->kind != kindCT) return (BuildUNKNOWN(newname(), false, false));
  1013.   if (ind1 > 0)
  1014.   return (selecttypes(ind1 - 1, ind2 - 1, ty->CT.tcrest));
  1015.   else
  1016.   return (BuildCT(ty->CT.tcfirst, selecttypes(0L, ind2 - 1, ty->CT.tcrest)));
  1017. }  /* selecttypes */
  1018.  
  1019. Local typcrec *typeval(appnon, vl, btns, splitlevel)
  1020. boolean appnon;
  1021. val vl;
  1022. envrec *btns;
  1023. long splitlevel;
  1024. /* gives type of vl;
  1025.    appnon is appset type: system application taken as adirectional
  1026.    btns: typenamings holding in types found in val
  1027.    splitlevel: nr. of ATOM/DEF/MAC blocks to be split out of
  1028.                curenv in local definitions */
  1029.  
  1030. { typcrec *ta, *tf, *t1, *t2;
  1031.   symbol hnm;
  1032.   envrec *conenv, *locenv;
  1033.   def hl;
  1034.   val hv;
  1035.  
  1036.   switch (vl->tag) {
  1037.  
  1038.   case TAGVApply:
  1039.     ta = typeval(false, vl->VApply.apar, btns, splitlevel);
  1040.     tf = typeval(false, vl->VApply.aval, btns, splitlevel);
  1041.     if (appnon) {
  1042.       t1 = BuildUNKNOWN(newname(), false, true);
  1043.       compat(BuildSYSTY(BuildOd(BuildNON()), t1), 
  1044.              tf, vl->VApply.aval);
  1045.       compat(t1, ta, vl->VApply.apar);
  1046.       return BuildAPS();
  1047.     } else {
  1048.       t1 = BuildUNKNOWN(newname(), false, true);
  1049.       t2 = BuildUNKNOWN(newname(), false, true);
  1050.       compat(BuildSYSTY(BuildCd(BuildOd(BuildIN()),
  1051.                  BuildCd(BuildOd(BuildOUT()),
  1052.                          BuildOd(BuildNON()))),
  1053.                BuildCT(t1, BuildCT(t2, BuildEMPTYT()))), tf,
  1054.           vl->VApply.aval);
  1055.       compat(t1, ta, vl->VApply.apar);
  1056.       return t2;
  1057.     }
  1058.     break;
  1059.  
  1060.   case TAGVSym:
  1061.     hnm = vl->VSym.sym;
  1062.     return typename(&hnm);
  1063.     break;
  1064.  
  1065.   case TAGVLambda:
  1066.     mark_(&curenv);
  1067.     mark_(&curenv);
  1068.     /* simulate empty block of ATOM/DEF/MAC decls. */
  1069.     splitcurenv(splitlevel, &conenv, &locenv);
  1070.     curenv = locenv;
  1071.     t1 = BuildSYSTY(BuildCd(BuildOd(BuildIN()),
  1072.        BuildCd(BuildOd(BuildOUT()), BuildOd(BuildNON()))),
  1073.      BuildCT(typefc(vl->VLambda.lpar),
  1074.        BuildCT(typeval(false, vl->VLambda.lval, btns, 0L),
  1075.          BuildEMPTYT())));
  1076.     release_(&curenv, false);
  1077.     /* the local connames of this lambda abstr. */
  1078.     curenv = conenv;
  1079.     return t1;
  1080.     break;
  1081.  
  1082.   case TAGVSigma:
  1083.     mark_(&curenv);
  1084.     mark_(&curenv);
  1085.     /* simulate empty block of ATOM/DEF/MAC decls. */
  1086.     splitcurenv(splitlevel, &conenv, &locenv);
  1087.     curenv = locenv;
  1088.     compat(BuildAPS(), typeval(true, vl->VSigma.sval, btns, 0L),
  1089.         vl->VSigma.sval);
  1090.     t1 = BuildSYSTY(BuildOd(BuildNON()),
  1091.                         typefc(vl->VSigma.spar));
  1092.     release_(&curenv, false);
  1093.     /* the local connames of this sigma abstr. */
  1094.     curenv = conenv;
  1095.     return t1;
  1096.     break;
  1097.  
  1098.   case TAGVWhere:
  1099.     mark_(&curenv);   /* after  formcons and conn. names */
  1100.     mark_(&btns);
  1101.     btns = extendbtns(vl->VWhere.wdefs, btns);
  1102.     extendenvloc(vl->VWhere.wdefs, btns);
  1103.     mark_(&curenv);   /* after ATOM/DEF/Mac names */
  1104.     hl = vl->VWhere.wdefs;
  1105.     while (hl != NULL) {
  1106.       compat(BuildAPS(), typeld(hl, btns, splitlevel + 1), NULL);
  1107.       /* compat always correct, so nil does not matter */
  1108.       hl = hl->next;
  1109.     }
  1110.     t1 = typeval(appnon, vl->VWhere.wval, btns,splitlevel+1);
  1111.     splitcurenv(splitlevel, &conenv, &locenv);
  1112.     curenv = locenv;
  1113.     checkdms(vl->VWhere.wdefs, btns);
  1114.     release_(&btns, false);
  1115.     release_(&curenv, false);   /* local ATOM/DEF/MACs removed */
  1116.     curenv = conenv;
  1117.     return t1;
  1118.     break;
  1119.  
  1120.   case TAGVList:
  1121.     if (vl->VList.l == NULL)
  1122.       return BuildEMPTYT();
  1123.     else {
  1124.       return
  1125.       BuildCT(typeval(false,vl->VList.l,btns,splitlevel),
  1126.               typeval(false, new_VList(vl->VList.l->next), btns,
  1127.                       splitlevel));
  1128.     }
  1129.     break;
  1130.  
  1131.   case TAGVAppset:
  1132.     t1 = BuildAPS();
  1133.     hv = vl->VAppset.aps;
  1134.     while (hv != NULL) {
  1135.       compat(t1, typeval(true, hv, btns, splitlevel), hv);
  1136.       hv = hv->next;
  1137.     }
  1138.     return t1;
  1139.     break;
  1140.  
  1141.   case TAGVAtom:
  1142.     hnm = vl->VAtom.atnm;
  1143.     tf = lookup(curenv, &hnm);
  1144.     if (tf != NULL) {
  1145.       while (tf->kind == kindSINGLEARROW || tf->kind == kindINDIR) {
  1146.      if (tf->kind == kindSINGLEARROW)
  1147.        tf = tf->SINGLEARROW.tcres;
  1148.      else
  1149.        tf = tf->INDIR.tcind;
  1150.       }
  1151.       ta = typeval(false, vl->VAtom.atcpar, btns, splitlevel);
  1152.       if (appnon) {
  1153.      t1 = BuildUNKNOWN(newname(), false, true);
  1154.      compat(BuildSYSTY(BuildOd(BuildNON()), t1), tf, vl);
  1155.      compat(t1, ta, vl->VAtom.atcpar);
  1156.      return BuildAPS();
  1157.       } else {
  1158.      t1 = BuildUNKNOWN(newname(), false, true);
  1159.      t2 = BuildUNKNOWN(newname(), false, true);
  1160.      compat(BuildSYSTY(BuildCd(BuildOd(BuildIN()),
  1161.                       BuildCd(BuildOd(BuildOUT()),
  1162.                            BuildOd(BuildNON()))),
  1163.                  BuildCT(t1, BuildCT(t2,BuildEMPTYT()))),tf,vl);
  1164.      compat(t1, ta, vl->VAtom.atcpar);
  1165.      return t2;
  1166.       }
  1167.     } else
  1168.       error(26L, NULL, NULL, hnm, NULL, false);
  1169.       return BuildUNKNOWN(newname(),false,false);
  1170.     break;
  1171.  
  1172.   case TAGVSyn:
  1173.     t1 = BuildUNKNOWN(newname(), false, true);
  1174.     hv = vl->VSyn.synlist;
  1175.     while (hv != NULL) {
  1176.       compat(t1, typeval(false, hv, btns, splitlevel), hv);
  1177.       hv = hv->next;
  1178.     }
  1179.     return BuildAPS();
  1180.     break;
  1181.  
  1182.   case TAGVComp:
  1183.     t1 = typeval(false, vl->VComp.vrest, btns, splitlevel);
  1184.     vl->VComp.typvc = t1;
  1185.     return BuildCT(typeval(false,vl->VComp.vfirst,btns,
  1186.                              splitlevel), 
  1187.                      t1);
  1188.     break;
  1189.  
  1190.   case TAGVInd:
  1191.     if (vl->VInd.vind < 0) {
  1192.       error(25L, NULL, NULL, NULL, vl, false);
  1193.       return BuildUNKNOWN(newname(), false, false);
  1194.     } else {
  1195.       t1 = typeval(appnon, vl->VInd.vexp, btns, splitlevel);
  1196.       atleast(vl->VInd.vind + 1, t1, vl);
  1197.       vl->VInd.typvi = t1;
  1198.       t2 = selecttypes(vl->VInd.vind, vl->VInd.vind, t1);
  1199.       if (t2->kind == kindCT)
  1200.      return t2->CT.tcfirst;
  1201.       else
  1202.      return BuildUNKNOWN(newname(), false, false);
  1203.     }
  1204.     break;
  1205.  
  1206.   case TAGVSlice:
  1207.     if (vl->VSlice.vind2 < vl->VSlice.vind1)
  1208.       return BuildEMPTYT();
  1209.     else {
  1210.       if (vl->VSlice.vind1 < 0) {
  1211.      error(25L, NULL, NULL, NULL, vl, false);
  1212.      return BuildUNKNOWN(newname(), false, false);
  1213.       } else {
  1214.      t1 = typeval(appnon, vl->VSlice.vexps, btns, splitlevel);
  1215.      atleast(vl->VSlice.vind2 + 1, t1, vl);
  1216.      vl->VSlice.typvs = t1;
  1217.      return selecttypes(vl->VSlice.vind1, vl->VSlice.vind2,
  1218.                           t1);
  1219.       }
  1220.     }
  1221.     break;
  1222.   }/* case */
  1223. }  /* typeval */
  1224.  
  1225. Void checksize(glass)
  1226. def_list glass;
  1227. { /* check if size of connections ok; if errors found, deliver
  1228.      errors, otherwise changed data structure */
  1229.   envrec *btns;
  1230.   def hdef, nw;
  1231.   _PROCEDURE TEMP;
  1232.  
  1233.   errordiscovered = false;
  1234.   forfull = false;
  1235.   marker = Buildsymbol("",0L); /* initialisation of a constant */
  1236.   namessupply = 0;
  1237.   nestednames = NULL;
  1238.   nestednorig = NULL;
  1239.   btns = emptyenv;
  1240.   mark_(&btns);
  1241.   btns = extendbtns(glass, btns);
  1242.   curenv = emptyenv;
  1243.   mark_(&curenv);
  1244.   extendenvloc(glass, btns);
  1245.   checkdms(glass, btns);
  1246.   release_(&btns, false);
  1247.   release_(&curenv, false);
  1248.   hdef = glass;
  1249.   if (errorlist == NULL) {
  1250.     while (hdef != NULL) {
  1251.       if (hdef->tag == TAGDefVal)
  1252.      replconsind(hdef->DefVal.valas, false, &nw);
  1253.       hdef = hdef->next;
  1254.     }
  1255.   }
  1256.   TEMP.proc = (Anyptr)unparsval;
  1257.   TEMP.link = (Anyptr)NULL;
  1258.   printerrors(TEMP, errorlist);
  1259. }  /* checksize */
  1260.